C---------------------------------------------------------
C    TOOLPACK/1    Release: 3.1
C---------------------------------------------------------
C
C  TOKEN STREAM BASED FORMAT STATEMENT 'CLUGGE' PROGRAM!
C
C  CHANGES FORMAT STATEMENTS ACCORDING TO STRANGE LOCAL REQUIREMENTS.
C  DOES THE FOLLOWING;
C     A) CONVERTS HOLLERITHS TO STRINGS
C     B) CONVERTS X FIELDS TO STRINGS
C     C) JOINS TOGETHER STRINGS ('A','B'  BECOMES  'AB')
C     D) DELETES COMMAS PRECEDING AND FOLLOWING SLASHES
C
C  NOTE: THE TOOL IS FOOLED BY EMBEDDED COMMENTS!
C
      PROGRAM ISTJS
 
      INTEGER TKNIN, TKNOUT, CMTIN, CMTOUT
      INTEGER TKNINM(81), TKNONM(81),
     +        CMTINM(81), CMTONM(81),
     +        OPTSTR(134)
 
      INTEGER OPEN, CREATE, GETARG, READCF
C
      CALL ZINIT
 
      IF (GETARG(1,TKNINM,81).EQ.-100) CALL NAMES(1,TKNINM)
      IF (GETARG(2,CMTINM,81).EQ.-100) CALL NAMES(2,CMTINM)
      IF (GETARG(3,TKNONM,81).EQ.-100) CALL NAMES(3,TKNONM)
      IF (GETARG(4,CMTONM,81).EQ.-100) CALL NAMES(4,CMTONM)
      IF (GETARG(5,OPTSTR,81).EQ.-100) CALL NAMES(5,OPTSTR)
C
C  OPEN AND CREATE THE REQUESTED FILES
C
      TKNIN =OPEN(TKNINM,0)
      IF (TKNIN .EQ.-1)
     +      CALL ERROR('ISTJS unable to open input token file.')
      CMTIN =OPEN(CMTINM,0)
      IF (CMTIN .EQ.-1)
     +      CALL ERROR('ISTJS unable to open input comment file.')
      TKNOUT=CREATE(TKNONM,1)
      IF (TKNOUT.EQ.-1)
     +      CALL ERROR('ISTJS unable to open output token file.')
      CMTOUT=CREATE(CMTONM,1)
      IF (CMTOUT.EQ.-1)
     +      CALL ERROR('ISTJS unable to open output comment file.')
C
C  INTERPRET THE REQUESTED OPTIONS THEN PROCESS THE FILE.....
C
      CALL DOOPT(OPTSTR)
      CALL TRNSFR(TKNIN, CMTIN, TKNOUT, CMTOUT)
C
      CALL ZMESS('[ISTJS: Normal Termination].', 1)
      CALL ZQUIT(-2)
      END
C-----------------------------------------------------------
C
C  PROMPT THE USER FOR NAMES THAT HAVE NOT BEEN SUPPLIED.......
C
      SUBROUTINE NAMES (NUMB,PATH)
 
      INTEGER NUMB,PATH(*)
 
      INTEGER ZGTCMD
      INTEGER JUNK,PROMPT(22, 5)
 
      DATA (PROMPT(I,1),I=1,19)/73,110,112,117,116,32,
     +116,111,107,101,110,32,102,105,108,101,58,32,129/
     +(PROMPT(I,2),I=1,21)/73,110,112,117,116,32,99,
     +111,109,109,101,110,116,32,102,105,108,101,58,32,129/
     +(PROMPT(I,3),I=1,20)/79,117,116,112,117,116,32,
     +116,111,107,101,110,32,102,105,108,101,58,32,129/
     +(PROMPT(I,4),I=1,22)/79,117,116,112,117,116,32,
     +99,111,109,109,101,110,116,32,102,105,
     +108,101,58,32,129/
     +(PROMPT(I,5),I=1,10)/79,112,116,105,111,110,115,
     +58,32,129/
 
      CALL ZPRMPT(PROMPT(1,NUMB))
      JUNK=ZGTCMD(PATH,0)
 
      END
C-----------------------------------------------------------
C
C  TOKEN STREAM EDITOR, COPIES THE INPUT TOKEN STREAM TO THE
C  OUTPUT TOKEN STREAM JOINING STRINGS IN FORMATS
C
      SUBROUTINE TRNSFR(TKNIN, CMTIN, TKNOUT, CMTOUT)
 
      INTEGER TKNIN, CMTIN, TKNOUT, CMTOUT, TKNTYP, TKNLEN,
     +        STATUS, I, J, DESCI, DESCO, POINT, C, COUNT,P,
     +        MAXENT, MAXSIZ, ENTRY, OFFSET, CTOI, ITOC, LASTTK,
     +        FROM, TO
      PARAMETER (MAXENT = 128)
      PARAMETER (MAXSIZ = 1322 * 3)
      INTEGER TKNSTR(1322), BUFFER(maxsiz),
     +        TYPES(MAXENT),LENTS(MAXENT),STRGS(MAXENT)
      LOGICAL COMMAS(MAXENT)
 
      INTEGER LENGTH, ZSETP, ZSETR, ZPREPL, ZTKGTI, ZTKPTI
      LOGICAL INFMT
 
      LOGICAL DOX, DOH,  DOJ, DOA
      COMMON /OPTION/ DOX, DOH,  DOJ, DOA
      SAVE /OPTION/
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.4
C---------------------------------------------------------
C
C  TKLAST = LAST TOKEN NUMBER
C
      INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
     +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
     +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
     +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
     +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
     +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
     +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
     +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
     +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
     +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
     +        TFMTKD,TENDKD,TERRKD,TKLAST
      PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
     +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
     +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
     +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
     +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
     +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
     +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
     +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
     +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
     +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
     +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
     +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
     +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
     +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
     +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
     +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
     +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
 
C
C  INITIALISE THE TOKEN STREAMS...................
C
      INFMT  = .FALSE.
      DESCI = ZTKGTI(1, TKNIN, CMTIN)
      DESCO = ZTKPTI(1, TKNOUT, CMTOUT)
      IF(DESCI .LE. 0 .OR. DESCO .LE. 0) CALL
     +   ERROR('[ISTJS] UNABLE TO INITIALSE TOKEN STREAMS.')
C
C  LOOP POINT.......
C
   10 CONTINUE
        CALL ZGETTK(TKNTYP,TKNLEN,TKNSTR,DESCI,STATUS)
C
C  HANDLE FORMAT STATEMENTS
C
C  - READ IN ALL THE TOKENS, CONVERTING HOLLERITHS TO STRINGS
C    IF REQUIRED.
C  - PROCESS THE FORMAT STATEMENT
C  - WRITE OUT ALL THE TOKENS, JOINING STRINGS TOGETHER
C
        IF(INFMT) THEN
          POINT = 1
          ENTRY = 0
C
C         READ IN THE TOKENS, CONVERT X AND H EDIT DESCRIPTORS TO STRINGS
C         IF THESE ARE REQUIRED OPTIONS, DELETE ALL COMMA TOKENS........
C
   20     CONTINUE
            IF(TKNTYP .EQ. TCMMNT) CALL REMARK(
     +         '[ISTJS] Warning - embedded comment in FORMAT statment.')
            IF(TKNTYP .NE. TCOMMA) THEN
              ENTRY = ENTRY + 1
              IF(ENTRY .GT. MAXENT) CALL ERROR
     +          ('[ISTJS] FORMAT STATEMENT TOO COMPLEX.')
              IF(DOH .AND. (TKNTYP .EQ. THCNST)) TKNTYP = TCCNST
              IF(TKNLEN .GT. 0) THEN
                IF((TKNTYP.EQ.TFIELD .AND. TKNSTR(TKNLEN).EQ.120) .OR.
     +             (TKNTYP.EQ.TFIELD .AND. TKNSTR(TKNLEN).EQ.88)) THEN
                  I = 1
                  LENTS(ENTRY) = CTOI(TKNSTR, I)
                  IF(DOX) THEN
                    TYPES(ENTRY) = TCCNST
                    IF(POINT+LENTS(ENTRY)+1 .GT. MAXSIZ) CALL ERROR
     +                ('[ISTJS] FORMAT STATEMENT TOO COMPLEX.')
                    DO 21 I = 1, LENTS(ENTRY)
                      BUFFER(POINT+I-1) = 32
   21               CONTINUE
                    STRGS(ENTRY) = POINT
                    BUFFER(POINT+LENTS(ENTRY)) = 129
                    POINT = POINT + LENTS(ENTRY) + 1
                  ELSE
                    TYPES(ENTRY) = -1
                  ENDIF
                ELSE
                  TYPES(ENTRY) = TKNTYP
                  LENTS(ENTRY) = TKNLEN
                  STRGS(ENTRY) = POINT
                  COMMAS(ENTRY) = .FALSE.
                  IF(POINT+LENTS(ENTRY)+1 .GT. MAXSIZ) CALL ERROR
     +                ('[ISTJS] FORMAT STATEMENT TOO COMPLEX.')
                  CALL SCOPY(TKNSTR, 1, BUFFER, POINT)
                  POINT = POINT + TKNLEN + 1
                ENDIF
              ELSE
                TYPES(ENTRY) = TKNTYP
                LENTS(ENTRY) = TKNLEN
                STRGS(ENTRY) = 1
                COMMAS(ENTRY) = .FALSE.
              ENDIF
            ELSE
              COMMAS(ENTRY) = .TRUE.
            ENDIF
 
            CALL ZGETTK(TKNTYP,TKNLEN,TKNSTR,DESCI,STATUS)
          IF(TKNTYP .NE. TZEOS) GO TO 20
C
C         CONVERT ADJACENT X EDIT DESCRIPTORS
C
          IF(DOA) THEN
            DO 25 I = 2, ENTRY-1
              IF(TYPES(I) .EQ. -1) THEN
                IF(TYPES(I-1).EQ.TCCNST.OR.TYPES(I+1).EQ.TCCNST) THEN
                  TYPES(I) = TCCNST
                  IF(POINT+LENTS(I)+1 .GT. MAXSIZ) CALL ERROR
     +                ('[ISTJS] UNABLE TO UNDO X EDIT DESCRIPTOR.')
                  DO 26 J = 1, LENTS(I)
                    BUFFER(POINT+J-1) = 32
   26               CONTINUE
                  STRGS(I) = POINT
                  BUFFER(POINT+LENTS(I)) = 129
                  POINT = POINT + LENTS(I) + 1
                ENDIF
              ENDIF
   25       CONTINUE
          ENDIF
C
C         WORRY ABOUT BLANKS IN STRINGS.....
C
          IF(DOJ) THEN
            DO 200 I = 1, ENTRY
              IF(TYPES(I) .EQ. -1) THEN
                IF(I .GT. 2) THEN
                  IF(TYPES(I-1).EQ.TCCNST) THEN
                    COUNT = 0
                    P = STRGS(I-1) + LENTS(I-1) - 1
  205               CONTINUE
                    IF(P-COUNT .GE. 1) THEN
                      IF(BUFFER(P-COUNT) .EQ. 32) THEN
                        COUNT = COUNT + 1
                        GO TO 205
                      ENDIF
                    ENDIF
                    BUFFER(P - COUNT + 1) = 129
                    LENTS(I-1) = LENTS(I-1) - COUNT
                    IF(LENTS(I-1) .EQ. 0) TYPES(I-1) = -2
                    LENTS(I) = LENTS(I) + COUNT
                  ENDIF
                ENDIF
 
                IF(I+1 .LE. ENTRY) THEN
                  IF(TYPES(I+1) .EQ. TCCNST) THEN
                    COUNT = 0
  235               CONTINUE
                    IF(STRGS(I+1)+COUNT .LT. POINT) THEN
                      C = BUFFER(STRGS(I+1)+COUNT)
                      IF(C .EQ. 32) THEN
                        COUNT = COUNT + 1
                        GO TO 235
                      ENDIF
                    ENDIF
                    LENTS(I+1) = LENTS(I+1) - COUNT
                    STRGS(I+1) = STRGS(I+1) + COUNT
                    IF(LENTS(I+1) .EQ. 0) TYPES(I+1) = -2
                    LENTS(I) = LENTS(I) + COUNT
                  ENDIF
                ENDIF
              ENDIF
 
  200       CONTINUE
C
C           CLEAR DEAD WOOD
C
            TO = 0
            DO 2999 I = 1, ENTRY
              IF(TYPES(I) .GE. -1) THEN
                TO = TO + 1
                TYPES(TO) = TYPES(I)
                LENTS(TO) = LENTS(I)
                STRGS(TO) = STRGS(I)
                COMMAS(TO) = COMMAS(I)
              ENDIF
 2999       CONTINUE
            ENTRY = TO
          ENDIF
C
C         JOIN STRINGS AND X EDIT DESCRIPTORS
C
          I = 1
   30     CONTINUE
            IF(I .LT. ENTRY) THEN
              IF((TYPES(I).EQ.TCCNST).AND.(TYPES(I+1).EQ.TCCNST)) THEN
                IF(POINT+LENTS(I)+LENTS(I+1)+1 .GT. MAXSIZ) CALL ERROR
     +                ('[ISTJS] UNABLE TO JOIN STRINGS.')
                CALL SCOPY(BUFFER, STRGS(I), BUFFER, POINT)
                STRGS(I) = POINT
                POINT = POINT + LENTS(I)
                CALL SCOPY(BUFFER, STRGS(I+1), BUFFER, POINT)
                POINT = POINT + LENTS(I+1) + 1
                LENTS(I) = LENTS(I) + LENTS(I+1)
                DO 31 J = I+2,ENTRY
                  TYPES(J-1) = TYPES(J)
                  LENTS(J-1) = LENTS(J)
                  STRGS(J-1) = STRGS(J)
                  COMMAS(J-1) = COMMAS(J)
   31           CONTINUE
                ENTRY = ENTRY - 1
                GO TO 30
              ENDIF
 
              IF((TYPES(I) .EQ. -1).AND.(TYPES(I+1) .EQ. -1)) THEN
                LENTS(I) = LENTS(I) + LENTS(I+1)
                DO 32 J = I+2,ENTRY
                  TYPES(J-1) = TYPES(J)
                  LENTS(J-1) = LENTS(J)
                  STRGS(J-1) = STRGS(J)
                  COMMAS(J-1) = COMMAS(J)
   32           CONTINUE
                ENTRY = ENTRY - 1
                GO TO 30
              ENDIF
            ENDIF
            I = I + 1
          IF(I .LT. ENTRY) GO TO 30
C
C         OUTPUT THE MODIFIED FORMAT STATEMENT
C
          LASTTK = TZEOS
          DO 50 I = 1, ENTRY
            IF(TYPES(I) .GT. 0) THEN
              CALL ZPUTTK(TYPES(I),LENTS(I),BUFFER(STRGS(I)),DESCO)
              LASTTK = TYPES(I)
            ELSE IF(TYPES(I) .EQ. -1) THEN
              C = ITOC(LENTS(I), TKNSTR, 10)
              TKNSTR(C+1) = 88
              TKNSTR(C+2) = 129
              TKNLEN = C + 1
              CALL ZPUTTK(TFIELD,TKNLEN,TKNSTR,DESCO)
              LASTTK = TFIELD
            ENDIF
            IF(COMMAS(I)) THEN
              IF(TYPES(I).EQ.TSLASH) GO TO 50
              IF(I+1.EQ.ENTRY) GO TO 50
              IF(I+1.LT.ENTRY) THEN
                IF(TYPES(I+1).EQ.TSLASH) GO TO 50
                IF(TYPES(I+1).EQ.TRPARN) GO TO 50
              ENDIF
              CALL ZPUTTK(TCOMMA,0,TKNSTR,DESCO)
            ENDIF
   50     CONTINUE
          CALL ZPUTTK(TZEOS, 0, TKNSTR, DESCO)
          INFMT = .FALSE.
C
C  HANDLE NON-FORMAT STATEMENTS, JUST PASS THEM STRAIGHT THROUGH
C  WITHOUT PROCESSING, BUT LOOK FOR THE NEXT FORMAT STATEMENT!
C
        ELSE
          IF(TKNTYP .EQ. TFORMA) INFMT = .TRUE.
          CALL ZPUTTK(TKNTYP, TKNLEN, TKNSTR, DESCO)
        ENDIF
 
      IF(TKNTYP .NE. TZEOF) GO TO 10
 
      END
C-----------------------------------------------------------------------
C
C  INTERPRET THE REQUESTED OPTIONS......
C
      SUBROUTINE DOOPT(STRING)
 
      INTEGER I
      INTEGER ZLOWER
      INTEGER STRING(*)
      LOGICAL DOX, DOH, DOJ, DOA
      COMMON /OPTION/ DOX, DOH, DOJ, DOA
      SAVE /OPTION/
 
      DOX = .FALSE.
      DOA = .FALSE.
      DOH = .TRUE.
      DOJ = .TRUE.
 
      I = 1
      CALL SKIPBL(STRING, I)
 
   10 CONTINUE
        IF(STRING(I) .EQ. 129) THEN
          RETURN
        ELSE IF(ZLOWER(STRING(I)) .EQ. 120) THEN
          DOX = .NOT. DOX
        ELSE IF(ZLOWER(STRING(I)) .EQ. 104) THEN
          DOH = .NOT. DOH
        ELSE IF(ZLOWER(STRING(I)) .EQ. 106) THEN
          DOJ = .NOT. DOJ
        ELSE IF(ZLOWER(STRING(I)) .EQ. 97) THEN
          DOA = .NOT. DOA
        ELSE IF(STRING(I) .EQ. 45 .OR. STRING(I) .EQ. 32) THEN
          CONTINUE
        ELSE
          CALL PUTCH(STRING(I), 2)
          CALL ZMESS(': Unknown Option, Ignored.', 2)
        ENDIF
        I = I + 1
      GO TO 10
 
      END
